home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / mac / files / ant_nec / nec_in_c.tz / nec_in_c / NEC2 / lwrite.c < prev    next >
C/C++ Source or Header  |  1992-02-13  |  3KB  |  192 lines
  1. #include "local.h"
  2. #include "f2c.h"
  3. #include "fio.h"
  4. #include "fmt.h"
  5. #include "lio.h"
  6. int L_len;
  7.  
  8. t_putc(c)
  9. {
  10.     recpos++;
  11.     putc(c,cf);
  12.     return(0);
  13. }
  14. lwrt_I(n) ftnint n;
  15. {
  16.     char buf[LINTW],*p;
  17. #ifdef USE_STRLEN
  18.     (void) sprintf(buf," %ld",(long)n);
  19.     if(recpos+strlen(buf)>=L_len)
  20. #else
  21.     if(recpos + sprintf(buf," %ld",(long)n) >= L_len)
  22. #endif
  23.         (*donewrec)();
  24.     for(p=buf;*p;PUT(*p++));
  25. }
  26. lwrt_L(n, len) ftnint n; ftnlen len;
  27. {
  28.     if(recpos+LLOGW>=L_len)
  29.         (*donewrec)();
  30.     (void) wrt_L((Uint *)&n,LLOGW, len);
  31. }
  32. lwrt_A(p,len) char *p; ftnlen len;
  33. {
  34.     int i;
  35.     if(recpos+len>=L_len)
  36.         (*donewrec)();
  37.     if (!recpos)
  38.         { PUT(' '); ++recpos; }
  39.     for(i=0;i<len;i++) PUT(*p++);
  40. }
  41.  
  42.  static int
  43. l_g(buf, n) char *buf; double n;
  44. {
  45. #ifdef Old_list_output
  46.     doublereal absn;
  47.     char *fmt;
  48.  
  49.     absn = n;
  50.     if (absn < 0)
  51.         absn = -absn;
  52.     fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  53. #ifdef USE_STRLEN
  54.     sprintf(buf, fmt, n);
  55.     return strlen(buf);
  56. #else
  57.     return sprintf(buf, fmt, n);
  58. #endif
  59.  
  60. #else
  61.     register char *b, c, c1;
  62.  
  63.     b = buf;
  64.     *b++ = ' ';
  65.     if (n < 0) {
  66.         *b++ = '-';
  67.         n = -n;
  68.         }
  69.     else
  70.         *b++ = ' ';
  71.     if (n == 0) {
  72.         *b++ = '0';
  73.         *b++ = '.';
  74.         *b = 0;
  75.         goto ret;
  76.         }
  77.     sprintf(b, LGFMT, n);
  78.     if (*b == '0') {
  79.         while(b[0] = b[1])
  80.             b++;
  81.         }
  82.     /* Fortran 77 insists on having a decimal point... */
  83.     else for(;; b++)
  84.         switch(*b) {
  85.             case 0:
  86.                 *b++ = '.';
  87.                 *b = 0;
  88.                 goto ret;
  89.             case '.':
  90.                 while(*++b);
  91.                 goto ret;
  92.             case 'E':
  93.                 for(c1 = '.', c = 'E';  *b = c1;
  94.                     c1 = c, c = *++b);
  95.                 goto ret;
  96.             }
  97.  ret:
  98.     return b - buf;
  99. #endif
  100.     }
  101.  
  102.  static void
  103. l_put(s) register char *s;
  104. {
  105.     register int c, (*pn)() = putn;
  106.     while(c = *s++)
  107.         (*pn)(c);
  108.     }
  109.  
  110. lwrt_F(n) double n;
  111. {
  112.     char buf[LEFBL];
  113.  
  114.     if(recpos + l_g(buf,n) >= L_len)
  115.         (*donewrec)();
  116.     l_put(buf);
  117. }
  118. lwrt_C(a,b) double a,b;
  119. {
  120.     char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  121.     int al, bl;
  122.  
  123.     al = l_g(bufa, a);
  124.     for(ba = bufa; *ba == ' '; ba++)
  125.         --al;
  126.     bl = l_g(bufb, b) + 1;    /* intentionally high by 1 */
  127.     for(bb = bufb; *bb == ' '; bb++)
  128.         --bl;
  129.     if(recpos + al + bl + 3 >= L_len && recpos)
  130.         (*donewrec)();
  131.     PUT(' ');
  132.     PUT('(');
  133.     l_put(ba);
  134.     PUT(',');
  135.     if (recpos + bl >= L_len) {
  136.         (*donewrec)();
  137.         PUT(' ');
  138.         }
  139.     l_put(bb);
  140.     PUT(')');
  141. }
  142. l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  143. {
  144. #define Ptr ((flex *)ptr)
  145.     int i;
  146.     ftnint x;
  147.     double y,z;
  148.     real *xx;
  149.     doublereal *yy;
  150.     for(i=0;i< *number; i++)
  151.     {
  152.         switch((int)type)
  153.         {
  154.         default: fatal(204,"unknown type in lio");
  155.         case TYSHORT:
  156.             x=Ptr->flshort;
  157.             goto xint;
  158.         case TYLONG:
  159.             x=Ptr->flint;
  160.         xint:    lwrt_I(x);
  161.             break;
  162.         case TYREAL:
  163.             y=Ptr->flreal;
  164.             goto xfloat;
  165.         case TYDREAL:
  166.             y=Ptr->fldouble;
  167.         xfloat: lwrt_F(y);
  168.             break;
  169.         case TYCOMPLEX:
  170.             xx= &Ptr->flreal;
  171.             y = *xx++;
  172.             z = *xx;
  173.             goto xcomplex;
  174.         case TYDCOMPLEX:
  175.             yy = &Ptr->fldouble;
  176.             y= *yy++;
  177.             z = *yy;
  178.         xcomplex:
  179.             lwrt_C(y,z);
  180.             break;
  181.         case TYLOGICAL:
  182.             lwrt_L(Ptr->flint, len);
  183.             break;
  184.         case TYCHAR:
  185.             lwrt_A(ptr,len);
  186.             break;
  187.         }
  188.         ptr += len;
  189.     }
  190.     return(0);
  191. }
  192.